perm filename TRANSF.OLD[IRC,LCS] blob sn#641764 filedate 1982-02-15 generic text, type T, neo UTF8
00100	C  READS IN TWO FILES FOR TRANSFORMATION
00200		IMPLICIT INTEGER (X-Z)
00300		DIMENSION RN(3)
00400	C  RN WILL HOLD FILE NAMES
00500		COMMON /A/X1(700),Y1(700),Z1(700),K1
00600		COMMON /B/X2(700),Y2(700),Z2(700),K2
00700		COMMON /C/X3(700),Y3(700),Z3(700),K3
00800		CALL READX(1)
00900		CALL READX(2)
01000		IF(K1.LT.K2)GO TO 1
01100		CALL REVERS
01200	1	CALL EQUALO
01300	C ASSUMES OUTLINE IS FIRST LONG CONTINUOUS LINE.
01400	C FIRST EQUALIZES OUTLINE, THEN THE REST
01500		CALL EQUALZ
01600	2	CALL PRCNTQ
01700		CALL OUTPUT
01800	C	GO TO 2
01900	100	END
02000	
02100		SUBROUTINE EQUALO
02200		COMMON /A/X1(700),Y1(700),Z1(700),K1
02300		COMMON /B/X2(700),Y2(700),Z2(700),K2
02400		COMMON /C/X3(700),Y3(700),Z3(700),K3
02450		COMMON /JO/JOUT1,JOUT2
02500		JOUT1=K1
02600		CALL FINDO(Z1,JOUT1)
02700		JOUT2=K2
02800		CALL FINDO(Z2,JOUT2)
02900		A=JOUT1
03000		B=JOUT2
03100		C=A/B
03200	C  C SHOULD BE < OR = TO 1
03300	100	A=1
03400		DO 1 K=1,JOUT2
03500		K3=A+.5
03600		X3(K)=X1(K3)
03700		Y3(K)=Y1(K3)
03800		Z3(K)=Z1(K3)
03900	1	A=A+C
04000	C NOW ARRAY C HAS SAME NUMB. OF OUTLINE POINTS AS B.
04100		K3=JOUT2
04200	200	END
04300	
04400		SUBROUTINE EQUALZ
04500		COMMON /A/X1(700),Y1(700),Z1(700),K1
04600		COMMON /B/X2(700),Y2(700),Z2(700),K2
04700		COMMON /C/X3(700),Y3(700),Z3(700),K3
04750		COMMON /JO/JOUT1,JOUT2
05200		A=K1-JOUT1
05300		B=K2-JOUT2
05400		C=A/B
05500	C  C SHOULD BE < OR = TO 1
05600		A=JOUT1+1
05700		DO 1 K=K3+1,K2
05800		N=A+.5
05900		X3(K)=X1(N)
06000		Y3(K)=Y1(N)
06100		Z3(K)=Z1(N)
06200	1	A=A+C
06300	C NOW REST OF ARRAY C HAS SAME NUMB. OF POINTS AS B.
06400	
06500	C BALANCE UP SOME OF THE VISIBLE-INVISIBLE MARKERS
06600		DO 2 K=K3+1,K2
06700		IF(X3(K).NE.X3(K-1))GO TO 2
06800		IF(Y3(K).NE.Y3(K-1))GO TO 2
06900		IF(Z3(K).NE.Z3(K-1))GO TO 2
07000		Z3(K)=Z2(K)
07100		Z3(K-1)=Z2(K-1)
07200	2	CONTINUE
07300		END
07900		SUBROUTINE PRCNTQ
07950		IMPLICIT INTEGER (X-Z)
08000		COMMON /A/X1(700),Y1(700),Z1(700),K1
08100		COMMON /B/X2(700),Y2(700),Z2(700),K2
08200		COMMON /C/X3(700),Y3(700),Z3(700),K3
08300	10	FORMAT(' TYPE PERCENT OF TRANSFORMATION (.5=50%)  ')
08400	11	FORMAT(F)
08500		TYPE 10
08600		ACCEPT 11,P
08800		DO 1 K=1,K2
10200		A=X2(K)-X3(K)
10300		A=A*P+.5
10400		B=Y2(K)-Y3(K)
10500		B=B*P+.5
10600		X3(K)=X3(K)+A
10700	1	Y3(K)=Y3(K)+B
12000		L=1
12100		DO 5 K=1,K2
12200		IF(Z3(K).EQ.Z2(K))GO TO 3
12300		A=X3(K+1)-X3(K)
12400		B=Y3(K+1)-Y3(K)
12500		IF(Z3(K).EQ.0)GO TO 2
12600	C NOW Z3=1 AND Z2=0
12700		A=A*P+.5
12800		B=B*P+.5
12900		Z1(L)=0
13000	4	X1(L)=X3(K)+A
13100		Y1(L)=Y3(K)+B
13200		L=L+1
13300		GO TO 3
13400	2	C=1.-P
13500		A=A*C+.5
13600		B=B*C+.5
13700		Z1(L)=1
13800		GO TO 4
14300	3	X1(L)=X3(K)
14400		Y1(L)=Y3(K)
14500		Z1(L)=Z3(K)
14600		L=L+1
14700	5	CONTINUE
14800		K1=L-1
14900		END